module HplAssets.Hephaestus.MetaProgramming where

import Language.Haskell.Syntax
import Data.Generics


-- ----------------------------------------------------------
-- Operators for Haskell program transformation
-- ----------------------------------------------------------

setModuleName :: String -> HsModule -> HsModule
setModuleName n 
              (HsModule _ (Module _) exportSpec importDecls decls) =	 
               HsModule noSrcLoc (Module n) exportSpec importDecls decls


addImportDecl :: String -> HsModule -> HsModule
addImportDecl n 
              (HsModule _ m exportSpec importDecls decls) =	 
               HsModule noSrcLoc m exportSpec importDecls' decls
 where
  importDecls' = importDecls ++
    [ HsImportDecl {
        importLoc = noSrcLoc,
        importModule = Module n, 
        importQualified = False,
        importAs = Nothing, 
        importSpecs = Nothing } ]


addField :: String -> String -> String -> HsModule -> HsModule
addField dataName fieldName typeName
         (HsModule _ m exportSpec importDecls decls) = 
          HsModule noSrcLoc m exportSpec importDecls (decls1 ++ [decl'] ++ decls2)
 where
  (decls1,decl,decls2) = findDataDecl dataName decls
  fieldType = HsUnBangedTy (HsTyCon (UnQual (HsIdent typeName)))
  decl' = case decl of
            (HsDataDecl _ [] n [] [HsRecDecl _ n' fields] []) ->
             let fields' = fields ++ [([HsIdent fieldName], fieldType)] in
              HsDataDecl noSrcLoc [] n [] [HsRecDecl noSrcLoc n' fields'] []
            _ -> error ("Datatype " ++ dataName ++ " not suitable.")


initializeField :: String -> String -> String -> HsModule -> HsModule
initializeField dataName fieldName funName = everywhere (mkT initializeField')
 where
  initializeField' :: HsExp -> HsExp
  initializeField' (HsRecConstr (UnQual (HsIdent n)) updates) | n == dataName =
                    HsRecConstr (UnQual (HsIdent n)) updates'
   where
    updates' = updates ++ [ HsFieldUpdate
                              (UnQual (HsIdent fieldName))
                              (HsVar (UnQual (HsIdent funName))) ]
  initializeField' x = x


--
-- This is a very specific (restricted) kind of constructor addition.
--
addConstructor :: String -> String -> HsModule -> HsModule
addConstructor dataName typeName 
               (HsModule _ m exportSpec importDecls decls) = 
                HsModule noSrcLoc m exportSpec importDecls (decls1 ++ [decl'] ++ decls2)
 where
  (decls1,decl,decls2) = findDataDecl dataName decls
  componentType = HsUnBangedTy (HsTyCon (UnQual (HsIdent typeName)))
  decl' = case decl of
            (HsDataDecl _ [] n [] conDecls []) ->
             let conDecls' = conDecls ++ [HsConDecl noSrcLoc (HsIdent typeName) [componentType]] in
              HsDataDecl noSrcLoc [] n [] conDecls' []
            _ -> error ("Datatype " ++ dataName ++ " not suitable.")


--
-- Please note that this operation makes rich assumptions.
--
addUpdateCase :: String -> String -> String -> [String] -> String -> HsModule -> HsModule
addUpdateCase funName funName' con argFuns sel
              (HsModule _ m exportSpec importDecls decls) = 
               HsModule noSrcLoc m exportSpec importDecls (decls1 ++ [decl'] ++ decls2)
 where
  (decls1, HsFunBind cases, decls2) = findFunBind funName decls
  decl' = HsFunBind (cases ++ [HsMatch noSrcLoc (HsIdent funName) (pat1:vpats) rhs []])
  var1 = HsIdent "x0"
  pat1 = HsPApp (UnQual (HsIdent con)) [HsPVar var1]
  argFuns' = map (HsVar . UnQual . HsIdent) (argFuns ++ [sel])
  vars = map (HsIdent . (++) "x" . show) [1..length argFuns']
  vexps = map (HsVar . UnQual) vars
  vpats = map HsPVar vars
  
  vars2 = map (HsIdent . (++) "x" . show) [0..length argFuns']
  vexps2 = map (HsVar . UnQual) vars2
  
  vars3 = map ((++) " x" . show) [0..length argFuns']
  
  -- usar foldl !!!! para resolver o erro de []
  -- HsUnGuardedRhs HsExp
  -- HsExp = HsApp HsExp HsExp
  -- HsExp = HsExpTypeSig SrcLoc HsExp HsQualType	
  -- HsExp = HsList [HsExp]
  --
  rhs = HsUnGuardedRhs (HsApp (HsApp (HsVar (UnQual (HsIdent funName'))) (HsVar (UnQual var1))) (vexps2)) --(HsParen (HsApp  (HsVar (UnQual (HsIdent " "))) vexps))) 
  -- funcionou abaixo
  --rhs = HsUnGuardedRhs (HsApp (HsVar (UnQual (HsIdent funName'))) (HsVar (UnQual (HsIdent (concat vars3)))))
  
   -- rhs = HsUnGuardedRhs (foldl apply fun' (zip vexps2 []))
   -- fun' = HsApp (HsVar (UnQual (HsIdent funName'))) (HsVar (UnQual var1)) 
   -- apply e (v,f) = HsApp e (HsParen (HsApp f v))
--  update r = HsRecUpdate (last vexps) [HsFieldUpdate (UnQual (HsIdent sel)) r]
  
--  rhs = HsUnGuardedRhs (update (foldl apply fun' (zip vexps argFuns')))
--  fun' = HsApp (HsVar (UnQual (HsIdent funName'))) (HsVar (UnQual var1)) 
--  apply e (v,f) = HsApp e (HsParen (HsApp f v))
--  update r = HsRecUpdate (last vexps) [HsFieldUpdate (UnQual (HsIdent sel)) r]
  
  
-- ----------------------------------------------------------
-- Utilities for the transformations
-- ----------------------------------------------------------

findDataDecl :: String -> [HsDecl] -> ([HsDecl], HsDecl, [HsDecl])
findDataDecl n decls = findDataDecl' [] decls 
 where
  findDataDecl' _ [] = error ("Datatype " ++ n ++ " not found.")
  findDataDecl' decls1 (decl@(HsDataDecl _ _ n' _ _ _):decls2)
    = if HsIdent n == n'
        then (decls1,decl,decls2)
        else findDataDecl' (decls1 ++ [decl]) decls2
  findDataDecl' decls1 (decl:decls2)
    = findDataDecl' (decls1 ++ [decl]) decls2


findFunBind :: String -> [HsDecl] -> ([HsDecl], HsDecl, [HsDecl])
findFunBind n decls = findFunBind' [] decls 
 where
  findFunBind' _ [] = error ("Function " ++ n ++ " not found.")
  findFunBind' decls1 (decl@(HsFunBind ((HsMatch _ n' _ _ _):_)):decls2)
    = if HsIdent n == n'
        then (decls1,decl,decls2)
        else findFunBind' (decls1 ++ [decl]) decls2
  findFunBind' decls1 (decl:decls2)
    = findFunBind' (decls1 ++ [decl]) decls2


noSrcLoc :: SrcLoc
noSrcLoc = undefined

undefinedRhs :: HsRhs
undefinedRhs = HsUnGuardedRhs (HsVar (UnQual (HsIdent "undefined")))
